home *** CD-ROM | disk | FTP | other *** search
/ Developer CD Series 1996 May: Tool Chest / Developer CD Series May 1996 (Tool Chest) (Apple Computer) (1996).iso / Tool Chest / Development Tools & Languages / Macintosh Common Lisp Related / User Contributions / Misc.sea / Misc / rulers.lisp < prev    next >
Encoding:
Text File  |  1993-02-26  |  6.1 KB  |  189 lines  |  [TEXT/CCL2]
  1. ;;; faultrease:rulers.lisp
  2. ;;; methods to draw rulers in a window
  3. ;;; this file is part of the faultrease system
  4. ;;; by: gregory c. wilcox
  5. ;;; arthur d. little, inc.
  6. ;;; october, 1992
  7.  
  8. ;;; to turn rulers on:  (setf (slot-value <window> 'rulers) <zoom>)
  9. ;;; to turn rulers off: (setf (slot-value <window> 'rulers) nil)
  10. ;;; where <window> is a scrolling-window-with-rulers
  11. ;;; and <zoom> is the zoom ratio
  12. ;;;
  13. ;;; when rulers are on, the current mouse location will be tracked
  14. ;;; in the rulers, using a gray pattern
  15. ;;;
  16. ;;; to set ruler units: (setq *ruler-units* <unit>)
  17. ;;; where <unit> is one of (inch centimeter point pixel)
  18.  
  19. (defvar *ruler-units* 'inch "Units used in rulers.")
  20.  
  21. (defvar *ruler-offset* (make-point 16 16) "View offset when rulers are in use.")
  22.  
  23. (defvar *mouse* 0 "Current location of the mouse.")
  24.  
  25. (defclass scrolling-window-with-rulers (ccl::scrolling-window)
  26.   ((rulers :initarg :rulers :initform nil)
  27.    ))
  28.  
  29. (defmacro axis-point (axis x y)
  30.   "Make a point along a given axis."
  31.   `(ecase ,axis
  32.      (x (make-point ,x ,y))
  33.      (y (make-point ,y ,x))
  34.      ))
  35.  
  36. (defmacro with-xor-gray-pen (&body body)
  37.   (let ((state (gensym)))
  38.     `(rlet ((,state :PenState))
  39.        (require-trap #_GetPenState ,state)
  40.        (require-trap #_PenPat *gray-pattern*)
  41.        ;; have to use :patxor (not :srcxor) so it works on monochrome machines
  42.        (require-trap #_PenMode ,(position :patxor *pen-modes*))
  43.        (unwind-protect (progn ,@body)
  44.          (require-trap #_SetPenState ,state)
  45.          ))))
  46.  
  47. (defun tic-size (j)
  48.   (let* ((i (mod j 8))
  49.          (k (logand i (- 8 i))))
  50.     (if (zerop k) 8 k)
  51.     ))
  52.  
  53. (defun draw-ruler (axis max zoom ppu)
  54.   "Draw a ruler along the X or Y axis."
  55.   (let ((width 16)
  56.         (scale (if (eq *ruler-units* 'point) 100 1)))
  57.     (frame-rect (axis-point axis width 0)
  58.                 (axis-point axis max width))
  59.     (with-font-spec '("geneva" 9 :plain)
  60.       (do* ((i 0 (1+ i))
  61.             (x width (+ width (round (* i (/ 1 8) ppu)))))
  62.            ((> x max))
  63.         (when (zerop (mod i 8))
  64.           (ecase axis
  65.             (x (move-to (+ x 2) 10))
  66.             (y (move-to 2 (- x 2))))
  67.           (with-pstrs ((string (prin1-to-string (* zoom scale (/ i 8)))))
  68.             (#_DrawString string)))
  69.         (let ((tic-length (ash (tic-size i) 1)))
  70.           (move-to (axis-point axis x (- width 1)))
  71.           (line-to (axis-point axis x (- width tic-length)))
  72.           )))))
  73.  
  74. (defun pixels-per-unit (axis)
  75.   (ecase *ruler-units*
  76.     (inch (ecase axis 
  77.             (x *pixels-per-inch-x*)
  78.             (y *pixels-per-inch-y*)))
  79.     ;; an educated guess. sue me
  80.     (centimeter 28)
  81.     ((point pixel) 100)
  82.     ))
  83.  
  84. (defmethod draw-rulers ((window scrolling-window-with-rulers))
  85.   "Draw rulers at the axes."
  86.   ;; rulers object variable used to hold the zoom ratio
  87.   (let* ((zoom (slot-value window 'rulers))
  88.          (size (view-size window))
  89.          (x (point-h size))
  90.          (y (point-v size))
  91.          )
  92.     (draw-ruler 'x x zoom (pixels-per-unit 'x))
  93.     (draw-ruler 'y y zoom (pixels-per-unit 'y))
  94.     ))
  95.  
  96. (defmethod add-rulers ((window scrolling-window-with-rulers))
  97.    (let* ((scroller (my-scroller window))
  98.           (new-size (subtract-points (view-size scroller)
  99.                                      *ruler-offset*)))
  100.      (set-view-size scroller new-size)
  101.      (set-view-position scroller *ruler-offset*)
  102.      ))
  103.  
  104. (defmethod remove-rulers ((window scrolling-window-with-rulers))
  105.    (let* ((scroller (my-scroller window))
  106.           (new-size (add-points (view-size scroller) *ruler-offset*)))
  107.      (set-view-size scroller new-size)
  108.      (set-view-position scroller (make-point 0 0))
  109.      ;; this could be done more efficiently
  110.      ;; using inval-rect on the ruler regions
  111.      (redraw window)
  112.      ))
  113.  
  114. (defmethod scroller-size ((window scrolling-window-with-rulers))
  115.   ;; allow for scroll bars
  116.   (let ((new-size (subtract-points (view-size window) #@(15 15))))
  117.     ;; allow for rulers, if present
  118.     (if (slot-value window 'rulers)
  119.       (subtract-points new-size *ruler-offset*)
  120.       new-size
  121.       )))
  122.  
  123. (defmethod my-scroller ((window scrolling-window-with-rulers))
  124.   (ccl::my-scroller window))
  125.  
  126. ;;; next three functions were
  127. ;;; adapted from functions in ccl;examples;scrolling-windows.lisp
  128. ;;; all that's missing is a definition of initialize-instance,
  129. ;;; after which scrolling-window-with-rulers could inherit directly from window
  130. ;;; and not need scrolling-windows
  131.  
  132. (defmethod set-view-size ((window scrolling-window-with-rulers) h &optional v)
  133.   "Modify (set-view-size scrolling-window) for rulers."
  134.   (declare (ignore h v))
  135.   (without-interrupts
  136.    (call-next-method)
  137.    (set-view-size (my-scroller window) (scroller-size window))
  138.    ))
  139.  
  140. (defmethod view-draw-contents ((window scrolling-window-with-rulers))
  141.   (call-next-method)
  142.   (when (slot-value window 'rulers)
  143.     (unless (hardcopy-p)
  144.       (draw-rulers window)
  145.       )))
  146.  
  147. (defmethod window-zoom-event-handler ((window scrolling-window-with-rulers) message)
  148.   (declare (ignore message))
  149.   (without-interrupts
  150.    (call-next-method)
  151.    (set-view-size (my-scroller window) (scroller-size window))
  152.    ))
  153.  
  154. (defmacro mark-rulers (location)
  155.   "Mark the current location on the rulers."
  156.   ;; speed-hacked and macro-ized since it's in the main event loop
  157.   `(let ((h (point-h ,location))
  158.          (v (point-v ,location)))
  159.      (declare (optimize (speed 3) (safety 0)))
  160.      (require-trap #_MoveTo 0 v)
  161.      (require-trap #_LineTo 16 v)
  162.      (require-trap #_MoveTo h 0)
  163.      (require-trap #_LineTo h 16)
  164.      ))
  165.  
  166. (defmethod show-location ((window scrolling-window-with-rulers))
  167.   "Track mouse motion in the rulers."
  168.   (let ((mouse (view-mouse-position window)))
  169.     (when (neq mouse *mouse*)
  170.       (with-focused-view window
  171.         (with-xor-gray-pen
  172.           ;; fencepost fixup
  173.           (unless (zerop *mouse*) (mark-rulers *mouse*))
  174.           (setq *mouse* mouse)
  175.           (mark-rulers *mouse*)
  176.           )))))
  177.  
  178. (defmethod window-event ((window scrolling-window-with-rulers))
  179.   "If rulers are on, show current mouse location."
  180.   (call-next-method)
  181.   (when (and
  182.          (slot-value window 'rulers)
  183.          ;; have to check this in case window event = close
  184.          (wptr window))
  185.     (show-location window)
  186.     ))
  187.  
  188. ;;; end of file
  189.